home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / filesys.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  113 lines
  1. ;;; Ops that create objects in the file system:
  2. ;;; create-{directory,fifo,hard-link,symlink}
  3. ;;; Copyright (c) 1993 by Olin Shivers.
  4.  
  5. ;;; This procedure nukes FNAME, whatever it may be: directory, file, fifo,
  6. ;;; symlink.
  7. ;;;
  8. ;;; We can't probe FNAME to find out what it is and then do the right
  9. ;;; delete operation because there's a window in-between the probe and the
  10. ;;; delete where the file system can be altered -- the probe and delete
  11. ;;; aren't atomic. In order to deliver on our contract, we have to spin
  12. ;;; in a funny loop until we win. In practice, the loop will probably never
  13. ;;; execute more than once.
  14.  
  15. (define (delete-filesys-object fname)
  16.   (let loop ()
  17.     (or (with-errno-handler ; Assume it's a file and try.
  18.         ((err data)
  19.          ((errno/perm) #f) ; Return #f if directory
  20.          ((errno/noent) #t))
  21.         (delete-file fname)
  22.         #t)
  23.  
  24.     (with-errno-handler ; Assume it's a directory and try.
  25.         ((err data)
  26.          ((errno/notdir) #f) ; Return #f if fname is not a directory.
  27.          ((errno/noent) #t))
  28.         (delete-directory fname)
  29.         #t)
  30.  
  31.     (loop)))) ; Strange things are happening. Try again.
  32.  
  33.  
  34. ;;; For similar reasons, all of these ops must loop.
  35.  
  36. ;;; Abstract out common code for create-{directory,fifo,hard-link,symlink}:
  37.  
  38. (define (create-file-thing fname makeit override? op-name syscall)
  39.   (let ((query (lambda ()
  40.          (y-or-n? (string-append op-name ": " fname
  41.                      " already exists. Delete")))))
  42.     (let loop ((override? override?))
  43.       ;; MAKEIT returns #f if win, errno if lose.
  44.       (cond ((makeit fname) =>
  45.          (lambda (err)
  46.            (if (not (= err errno/exist))
  47.            (errno-error err syscall fname)
  48.  
  49.            ;; FNAME exists. Nuke it and retry?
  50.            (cond ((if (eq? override? 'query)
  51.                   (query)
  52.                   override?)
  53.               (delete-filesys-object fname)
  54.               (loop #t))
  55.              (else
  56.               (errno-error err syscall fname))))))))))
  57.  
  58.  
  59. ;;;;;;;
  60.  
  61. (define (create-directory dir . rest)
  62.   (let ((perms (if (null? rest) #o777 (car rest)))
  63.     (override? (if (or (null? rest) (null? (cdr rest))) #f
  64.                (cadr rest))))
  65.     (create-file-thing dir
  66.                (lambda (dir) (create-directory/errno dir perms))
  67.                override?
  68.                "create-directory"
  69.                create-directory)))
  70.  
  71. (define (create-fifo fifo . rest)
  72.   (let ((perms (if (null? rest) #o777 (car rest)))
  73.     (override? (if (or (null? rest) (null? (cdr rest))) #f
  74.                (cadr rest))))
  75.     (create-file-thing fifo
  76.                (lambda (fifo) (create-fifo/errno fifo perms))
  77.                override?
  78.                "create-fifo"
  79.                create-fifo)))
  80.  
  81. (define (create-hard-link old-fname new-fname . maybe-override?)
  82.   (create-file-thing new-fname
  83.              (lambda (new-fname)
  84.                (create-hard-link/errno old-fname new-fname))
  85.              (optional-arg maybe-override? #f)
  86.              "create-hard-link"
  87.              create-hard-link))
  88.  
  89. (define (create-symlink old-fname new-fname . maybe-override?)
  90.   (create-file-thing new-fname
  91.              (lambda (symlink)
  92.                (create-symlink/errno old-fname symlink))
  93.              (optional-arg maybe-override? #f)
  94.              "create-symlink"
  95.              create-symlink))
  96.  
  97. ;;; Unix rename() works backwards from mkdir(), mkfifo(), link(), and 
  98. ;;; symlink() -- it overrides by default, (though insisting on a type
  99. ;;; match between the old and new object). So we can't use create-file-thing.
  100. ;;; Note that this loop has a tiny atomicity problem -- if someone
  101. ;;; creates a file *after* we do our existence check, but *before* we 
  102. ;;; do the rename, we could end up overriding it, when the user asked
  103. ;;; us not to. That's life in the food chain.
  104.  
  105. (define (rename-file old-fname new-fname . maybe-override?)
  106.   (let ((override? (optional-arg maybe-override? #f)))
  107.     (if (or (and override? (not (eq? override? 'query)))
  108.         (file-not-exists? new-fname)
  109.         (and override?
  110.          (y-or-n? (string-append "rename-file:" new-fname
  111.                      " already exists. Delete"))))
  112.     (%rename-file old-fname new-fname))))
  113.